Sub CreateReadDocFast()
    Dim originalDoc As Document
    Dim newDoc As Document
    Dim savePath As String
    Dim originalFolderPath As String
    Dim originalFilePath As String
    
    ' Disable screen updating for faster execution
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' Save the document
    ActiveDocument.SaveAs2

    ' Assign the original document to a variable
    Set originalDoc = ActiveDocument
    
    ' Extract the folder path from the original document's file path
    originalFolderPath = Left(originalDoc.FullName, InStrRev(originalDoc.FullName, Application.PathSeparator))
    originalFilePath = originalDoc.FullName
    
    ' Set the save path for the modified document in the same folder as the original document
    savePath = originalFolderPath & "READ_" & originalDoc.Name
    
    ' Create a duplicate of the original document
    originalDoc.SaveAs2 Filename:=savePath, FileFormat:=wdFormatXMLDocument
    Set newDoc = Documents.Open(savePath)
    
    ' Call the InvisibilityOnFast method to perform the transformations
    Call InvisibilityOnFast(newDoc)
    
    ' Reopen the original document using its file path
    Documents.Open originalFilePath
    
    ' Save and close the modified document without prompts
    newDoc.Close SaveChanges:=wdSaveChanges
    
    ' Enable screen updating and alerts
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    ' Inform the user about the completion
    MsgBox "Read version created and saved as " & savePath
End Sub

Sub InvisibilityOnFast(targetDoc As Document)
    Dim i As Long

    ' Move the cursor to the beginning of the document
    targetDoc.Content.Select
    Selection.HomeKey Unit:=wdStory

    ' Delete all text with the color RGB(85, 85, 85)
    With ActiveDocument.Content.Find
        .ClearFormatting
        .Text = ""
        .Font.Color = RGB(85, 85, 85)
        .Replacement.ClearFormatting
        .Replacement.Text = ""
        .Execute Replace:=wdReplaceAll, Forward:=True, Wrap:=wdFindContinue
    End With

    ' Replace all paragraph marks with highlighted and bolded paragraph marks
    With targetDoc.Content.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "^p"
        .Replacement.Text = "^p"
        .Replacement.Style = "Underline"
        .Replacement.Highlight = True
        .Replacement.Font.Bold = True
        .MatchWildcards = False
        .Execute Replace:=wdReplaceAll
    End With

    ' Delete non-highlighted "Normal" text
    With targetDoc.Content.Find
        .ClearFormatting
        .Style = "Normal"
        .Highlight = False
        .Font.Bold = False
        .Replacement.ClearFormatting
        .Text = ""
        .Replacement.Text = " "
        .Execute Replace:=wdReplaceAll
    End With

    ' Delete non-highlighted "Underline" text
    With targetDoc.Content.Find
        .ClearFormatting
        .Style = "Underline"
        .Highlight = False
        .Replacement.ClearFormatting
        .Text = ""
        .Replacement.Text = " "
        .Execute Replace:=wdReplaceAll
    End With

    ' Delete non-highlighted "Undertag" text
    With Selection.Find
        .ClearFormatting
        .Style = "Undertag"
        .Highlight = False
        .Replacement.ClearFormatting
        .Text = ""
        .Replacement.Text = " "
        .Execute Replace:=wdReplaceAll
    End With

    ' Delete non-highlighted "Emphasis" text
    With targetDoc.Content.Find
        .ClearFormatting
        .Style = "Emphasis"
        .Highlight = False
        .Replacement.ClearFormatting
        .Text = ""
        .Replacement.Text = " "
        .Execute Replace:=wdReplaceAll
    End With

    ' Remove extra spaces between paragraph marks
    With targetDoc.Content.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "^p ^p"
        .Replacement.Text = ""
        .Replacement.Highlight = False
        .Execute Replace:=wdReplaceAll
    End With

    ' Remove consecutive spaces in non-highlighted text
    With targetDoc.Content.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "( ){2,}"
        .Highlight = False
        .MatchWildcards = True
        .Replacement.Text = " "
        .Execute Replace:=wdReplaceAll
    End With

    ' Remove spaces at the beginning of paragraphs
    With targetDoc.Content.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "^p "
        .Replacement.Text = "^p"
        .MatchWildcards = False
        .Execute Replace:=wdReplaceAll
    End With

    ' Remove consecutive paragraph marks in non-highlighted text
    With targetDoc.Content.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "^13{1,}"
        .Replacement.Text = "^p"
        .MatchWildcards = True
        .Execute Replace:=wdReplaceAll
    End With

    ' Clean up and suppress errors
    targetDoc.Content.Find.ClearFormatting
    targetDoc.Content.Find.MatchWildcards = False
    targetDoc.Content.Find.Replacement.ClearFormatting
    targetDoc.ShowGrammaticalErrors = False
    targetDoc.ShowSpellingErrors = False
End Sub